Chip 1996 September/CHIP 1996 szeptember (CD07).zip/CHIP_CD07.ISO/sac/pack/vblha1.lzh/MAIN.FRM

Text File | 1995-05-08 | 15KB | 694 lines

VERSION 2.00
Begin Form frmMain
   ClientHeight    =   4035
   ClientLeft      =   375
   ClientTop       =   1920
   ClientWidth     =   8625
   Height          =   4770
   Left            =   315
   LinkTopic       =   "Form2"
   ScaleHeight     =   4035
   ScaleWidth      =   8625
   Top             =   1245
   Width           =   8745
   Begin PictureBox picStatus
      Align           =   2  'Align Bottom
      BackColor       =   &H00C0C0C0&
      Height          =   255
      Left            =   0
      ScaleHeight     =   225
      ScaleWidth      =   8595
      TabIndex        =   3
      Top             =   3780
      Width           =   8625
      Begin TextBox txtMemo
         BackColor       =   &H00C0C0C0&
         Height          =   285
         Left            =   3840
         TabIndex        =   9
         Top             =   0
         Width           =   1335
      End
      Begin TextBox txtFname
         BackColor       =   &H00C0C0C0&
         Height          =   285
         Left            =   2640
         TabIndex        =   6
         Top             =   0
         Width           =   1215
      End
      Begin TextBox txtName
         BackColor       =   &H00C0C0C0&
         Height          =   285
         Left            =   1200
         TabIndex        =   5
         Top             =   0
         Width           =   1455
      End
      Begin TextBox txtID
         BackColor       =   &H00C0C0C0&
         Height          =   285
         Left            =   120
         TabIndex        =   4
         Top             =   0
         Width           =   1095
      End
   End
   Begin ComboBox cboID
      Height          =   300
      Left            =   1320
      Style           =   2  'Dropdown List
      TabIndex        =   2
      Top             =   120
      Width           =   1815
   End
   Begin PictureBox PicControl
      Align           =   1  'Align Top
      BackColor       =   &H00C0C0C0&
      FillColor       =   &H00FFFFFF&
      Height          =   495
      Left            =   0
      ScaleHeight     =   465
      ScaleWidth      =   8595
      TabIndex        =   1
      Top             =   0
      Width           =   8625
      Begin TextBox txtFrom
         Height          =   285
         Left            =   5760
         TabIndex        =   13
         Top             =   120
         Width           =   1215
      End
      Begin TextBox txtSub
         Height          =   285
         Left            =   3600
         TabIndex        =   11
         Top             =   120
         Width           =   1575
      End
      Begin OptionButton optMemo
         BackColor       =   &H00C0C0C0&
         Caption         =   "&Memo"
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "Arial"
         FontSize        =   8.25
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         Height          =   255
         Left            =   600
         TabIndex        =   10
         Top             =   0
         Width           =   1095
      End
      Begin OptionButton optName
         BackColor       =   &H00C0C0C0&
         Caption         =   "&Name"
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "Arial"
         FontSize        =   8.25
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         Height          =   255
         Left            =   120
         TabIndex        =   8
         Top             =   240
         Width           =   735
      End
      Begin OptionButton optID
         BackColor       =   &H00C0C0C0&
         Caption         =   "&ID"
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "Arial"
         FontSize        =   8.25
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         Height          =   255
         Left            =   120
         TabIndex        =   7
         Top             =   0
         Width           =   495
      End
      Begin Label lblFrom
         BackColor       =   &H00C0C0C0&
         Caption         =   "From:"
         Height          =   255
         Left            =   5280
         TabIndex        =   14
         Top             =   120
         Width           =   495
      End
      Begin Label lblSub
         BackColor       =   &H00C0C0C0&
         Caption         =   "Sub:"
         Height          =   255
         Left            =   3240
         TabIndex        =   12
         Top             =   120
         Width           =   375
      End
   End
   Begin TextBox txtWorkarea
      BorderStyle     =   0  'None
      Height          =   1815
      Left            =   0
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   0
      Top             =   480
      Width           =   3375
   End
   Begin Menu mnuFile
      Caption         =   "&File"
      Begin Menu mnuNew
         Caption         =   "&New"
      End
      Begin Menu mnuOpen
         Caption         =   "&Open"
      End
      Begin Menu mnuSave
         Caption         =   "&Save"
      End
      Begin Menu mnuClose
         Caption         =   "&Close"
      End
      Begin Menu mnuSep1
         Caption         =   "-"
      End
      Begin Menu mnuFDelete
         Caption         =   "&Delete"
      End
      Begin Menu mnuTrash
         Caption         =   "&Trash"
      End
      Begin Menu mnuSep2
         Caption         =   "-"
      End
      Begin Menu mnuExit
         Caption         =   "E&xit"
      End
   End
   Begin Menu mnuEdit
      Caption         =   "&Edit"
      Begin Menu mnuCut
         Caption         =   "Cu&t"
      End
      Begin Menu mnuCopy
         Caption         =   "&Copy"
      End
      Begin Menu mnuPaste
         Caption         =   "&Paste"
      End
      Begin Menu mnuDelete
         Caption         =   "&Delete"
      End
   End
   Begin Menu mnuView
      Caption         =   "&View"
   End
   Begin Menu mnuOptions
      Caption         =   "&Options"
   End
End
Option Explicit

Dim TotalRec As Long

Sub cboID_Click ()

'Update status bar
procStatusBar

End Sub

Sub Form_Activate ()

'Update status bar
procStatusBar

'Set file name to default
If workfile.fopen = "" Then
 frmMain.Caption = txtFname.Text
End If

End Sub

'Copyright 1995 by Hitoshi Ozawa
Sub Form_Load ()

' Load the frmGetFile dialog box without displaying
Load frmGetFile

'Initialize the cboFileType combo box of the frmGetFile
frmGetFile.cboFileType.AddItem "Text files (*.txt)"
frmGetFile.cboFileType.AddItem "All files (*.*)"
frmGetFile.cboFileType.AddItem "LHA files (*.LZH)"
frmGetFile.cboFileType.ListIndex = 0

'Initialize to ID selection
optID.Value = True

'Initialize ID combo list
procGetID

End Sub

Sub Form_Resize ()

picControl.ScaleWidth = frmMain.ScaleWidth

txtWorkArea.Width = frmMain.ScaleWidth
txtWorkArea.Height = frmMain.ScaleHeight - picControl.ScaleHeight - picStatus.ScaleHeight

End Sub

'Copyright 1995 by Hitoshi Ozawa
Sub mnuClose_Click ()

'Clear text area
txtWorkArea.Text = ""
frmMain.Caption = ""

'Reset filenames
workfile.lopen = ""
workfile.fopen = ""

'Refresh frmGetfile
frmGetFile.txtFileName.Text = ""
frmGetFile.filFiles.Pattern = "*.txt"
frmGetFile.filFiles.Refresh

End Sub

Sub mnuCopy_Click ()

'Clear the clipboard
Clipboard.Clear

'Transfer to the clipboard
Clipboard.SetText txtWorkArea.SelText

End Sub

Sub mnuCut_Click ()

'Clear the clipboard
Clipboard.Clear

'Transfer to the clipboard
Clipboard.SetText txtWorkArea.SelText

'Delete the current selected aread
txtWorkArea.SelText = ""

End Sub

Sub mnuDelete_Click ()

'Delete selected area
txtWorkArea.SelText = ""

End Sub

'Copyright 1995 by Hitoshi Ozawa
Sub mnuExit_Click ()
  End
End Sub

Sub mnuFDelete_Click ()
 procDel
End Sub

Sub mnuNew_Click ()

'Clear text area
txtWorkArea.Text = ""
frmMain.Caption = ""

'Reset filenames
workfile.lopen = ""
workfile.fopen = ""

procStatusBar

End Sub

'Copyright 1995 by Hitoshi Ozawa
Sub mnuOpen_Click ()

Dim retcode As Integer

'Initialize file name to null
workfile.lopen = ""

'Display the frmGetFile as modal
curForm = fGet
frmGetFile.Show 1
curForm = fMain

'Change file name in status bar
txtFname.Text = workfile.fopen

'Change window caption
If workfile.lopen = "" Then
 frmMain.Caption = workfile.fopen
Else
 frmMain.Caption = workfile.lopen & "(" & workfile.fopen & ")"
End If


'If not text file Execute file
Select Case LCase$(Right$(frmGetFile.Tag, 3))
 Case "exe"
   retcode = Shell(frmGetFile.Tag, 1)
 Case "com"
   retcode = Shell(frmGetFile.Tag, 1)
 Case "bat"
   retcode = Shell(frmGetFile.Tag, 1)
 Case "wri"
   retcode = Shell("write.exe " & frmGetFile.Tag, 1)
 Case Else   'if not any of above, treat at text file
  'Get file number
   FileNum = FreeFile

   'Open file for input
   If Len(frmGetFile.Tag) Then
     Open frmGetFile.Tag For Binary As FileNum    ' open file for input
     txtWorkArea.Text = Input$(LOF(FileNum), FileNum)

     'Close file
     Close FileNum

   End If
End Select

End Sub

Sub mnuPaste_Click ()

'Replace current selected area with content of clipboard
txtWorkArea.SelText = Clipboard.GetText()

End Sub

'Copyright 1995 by Hitoshi Ozawa
Sub mnuSave_Click ()

Dim retcode As Integer
Dim curpath As String
Dim cnt

'File name not entered - default to txtFname
If frmGetFile.Tag = "" Then
  workfile.lopen = ""
  procMsave
  Exit Sub
End If

If workfile.fopen = "" Then
 procSave
Else
 Select Case LCase$(Right$(frmGetFile.Tag, 3))
  Case "exe"
   retcode = Shell(frmGetFile.Tag, 1)
  Case "com"
   retcode = Shell(frmGetFile.Tag, 1)
  Case "bat"
   retcode = Shell(frmGetFile.Tag, 1)
  Case "wri"
   retcode = Shell("write.exe " & frmGetFile.Tag, 1)
  Case Else   'if not any of above, treat at text file
   procSave
 End Select
End If

'Refresh file list
frmGetFile.filFiles.Refresh

End Sub

Sub mnuTrash_Click ()
  procTrash
End Sub

Sub optID_Click ()

'Recreate Combo IDs
procGetID

End Sub

Sub optMemo_Click ()

'Recreate Combo IDs
procGetID

End Sub

Sub optName_Click ()

'Recreate Combo IDs
procGetID

End Sub

Sub procGetID ()

Dim Person As PersonInfo
Dim FileNum As Integer
Dim RecordLen As Long
Dim CurrentRecord As Long

'Clear Combo IDs
cboID.Clear

'Calculate length of record
RecordLen = Len(Person)

'Get a file number
FileNum = FreeFile

On Error GoTo NOID

'Open file from random access. Create file if doesn't exist
Open "USERS.DAT" For Random As FileNum Len = RecordLen

CurrentRecord = 1

Do While Not EOF(FileNum)
  Get #FileNum, CurrentRecord, Person
  If optID.Value = True Then
   cboID.AddItem Trim(Person.ID)
  ElseIf optName.Value = True Then
   cboID.AddItem Trim(Person.Name)
  Else
   cboID.AddItem Trim(Person.Memo)
  End If
  CurrentRecord = CurrentRecord + 1
Loop

TotalRec = CurrentRecord

'Close file
Close FileNum

'Set default to first ID
cboID.ListIndex = 0

NOID:
Exit Sub

End Sub

Sub procMsave ()

Dim retcode As Integer
Dim curpath As String
Dim cnt
Dim savefile As String

'Get file number
FileNum = FreeFile

savefile = Trim(filedir.sdir) & txtFname.Text

'Open file for input
Open savefile For Output As FileNum

Print #FileNum, "TO:" & txtID.Text
Print #FileNum, "SUB:" & txtSub.Text & Chr(10)

If txtFrom.Text <> "" Then
 Print #FileNum, "FROM:" & txtFrom.Text
End If

'Output contents to text area
Print #FileNum, txtWorkArea.Text

'Close file
Close FileNum

End Sub

Sub procSave ()

Dim retcode As Integer
Dim curpath As String
Dim cnt

 'Get file number
 FileNum = FreeFile

 'Open file for input
 Open frmGetFile.Tag For Output As FileNum

 'Output contents to text area
 Print #FileNum, txtWorkArea.Text

 'Close file
 Close FileNum

'If it was a LZH file, update LZH file and delete text file
If workfile.lopen <> "" Then

 'Save current path
 curpath = CurDir

 'Reset buffer size
 buffer = Space(szbuff)

 ChDrive Mid$(frmGetFile.Tag, 1, 2)
 ChDir frmGetFile.filFiles.Path

'Create LHA command
 cmd = "a " & workfile.lopen & " " & workfile.fopen

 'Perform LHA operation
 retcode = lha(cmd, buffer, szbuff)

 'Check for error
 If retcode <> 0 Then
  MsgBox ("Refresh error: " & retcode)
  Exit Sub
 End If

 'Delete extracted file
 Kill workfile.fopen

 'Return to original drive
 ChDrive Mid$(curpath, 1, 2)

 'Return to original path
 ChDir curpath

End If
End Sub

Sub procStatusBar ()
Dim Person As PersonInfo
Dim FileNum As Integer
Dim RecordLen As Long
Dim today

'Calculate length of record
RecordLen = Len(Person)

'Get a file number
FileNum = FreeFile

On Error GoTo STERRORID

'Open file from random access. Create file if doesn't exist
Open "USERS.DAT" For Random As FileNum Len = RecordLen

Get #FileNum, cboID.ListIndex + 1, Person

'Update status bar
txtID.Text = Trim(Person.ID)
txtName.Text = Trim(Person.Name)
txtMemo.Text = Trim(Person.Memo)

'If there is no file name
If workfile.fopen = "" Then
 'Build filename using today's date
 today = Now
 txtFname.Text = Trim(Person.Fname) & Format(today, "yymmdd") & "." & Trim(Person.Fext)

 'Reset Header filename
 frmMain.Caption = txtFname.Text
End If

'Close file
Close FileNum

STERRORID:
Exit Sub

End Sub

Sub procWriteID ()
Dim Person As PersonInfo
Dim FileNum As Integer
Dim RecordLen As Long
Dim pos

'Calculate length of record
RecordLen = Len(Person)

'Get a file number
FileNum = FreeFile

On Error GoTo WRERRORID

'Open file from random access. Create file if doesn't exist
Open "USERS.DAT" For Random As FileNum Len = RecordLen

'Set record
Person.ID = txtID.Text
Person.Name = txtName.Text
Person.Memo = txtMemo.Text

pos = InStr(txtFname.Text, ".")
If pos = 0 Then
 Person.Fname = txtFname.Text
 Person.Fext = ""
ElseIf pos < 2 Then
 Person.Fname = ""
 Person.Fext = Mid$(txtFname.Text, 2)
ElseIf pos < 3 Then
 Person.Fname = Left$(txtFname.Text, 1)
 Person.Fext = Mid$(txtFname.Text, pos + 1)
Else
 Person.Fname = Left$(txtFname.Text, 2)
 Person.Fext = Mid$(txtFname.Text, pos + 1)
End If

'Output record
Put #FileNum, cboID.ListIndex + 1, Person

'Close file
Close FileNum

WRERRORID:
Exit Sub

End Sub

Sub txtFname_LostFocus ()

'Save changes
procWriteID

End Sub

Sub txtMemo_LostFocus ()

'Save changes
procWriteID

End Sub